Infix for All (листья)

Infix [] работает только на первом уровне:

Infix[(c a^b)^d]
(*
-> (a^b c) ~Power~ d
*)

Поскольку я хочу (не спрашивайте почему) переключить полное выражение на инфиксную нотацию, я попробовал что-то вроде:

SetAttributes[toInfx, HoldAll];
toInfx[expr_] := Module[{prfx, infx},
  prfx = Level[expr, {0, Infinity}];
  infx = Infix /@ prfx /. {Infix[a_Symbol] -> a, Infix[a_?NumericQ] -> a};
  Fold[ReplaceAll[#1, #2] &, expr, Reverse@Thread[Rule[prfx, infx]]]
  ]
k = toInfx[(c a^b)^d]
(*
-> (c ~Times~ (a ~Power~ b)) ~Power~ d
*)

Но здесь есть две очевидные проблемы, потому что

1. (ca ^ b ) ^ d == a ~ Power ~ b ~ Times ~ c ~ Power ~ d
   Итак, я получил неэффективное использование инфикса.
2. Это ненадежно и не работает для простых выражений, таких как k = toInfx [a / b + ArcTan [a / b]]

Есть ли простой способ получить Infix [] работает для всех (листья)?