ParametricNDSolveValue::ndsz: At r == 0.0004036933699289324`, step size is effectively zero; singularity or stiff system suspected. >>

Potential[x_] := 5.154462413581529*^7 - 256000000*(1 - x)^2 + 128000000*(1 - x)^4 - 1.030892482716306*^8*x^2 + 8.049495987048458*^8*(1 - x)^2*x^2 + 5.154462413581531*^7*x^4

test = ParametricNDSolveValue[{(Derivative[2][t][r] + (2/r)*Derivative[1][t][r] - D[Potential[x], x] /. x -> t[r]) == 0, t[10^(-12)] == d,
 Derivative[1][t][10^(-12)] == 0}, t[0.5], {r, 10^(-12), 1}, {d}];

C = 0.0005;
d = 0.002;
Under = 1;
Monitor[Quiet[While[C >= 10^(-18), While[Under == 1, d = d - C; If[Abs[test[d]] > 1 || d < 0, Under = 0]; ]; d = d + C; C = C/10; Under = 1; ]; ], d]

test = ParametricNDSolveValue[{(Derivative[2][t][r] + (2/r)*
    Derivative[1][t][r] - D[Potential[x], x] /. x -> t[r]) == 0,
    t[10^(-12)] == d, Derivative[1][t][10^(-12)] == 0}, t, {r, 10^(-12), 1}, {d}]

test[.001]["Domain"][[1, 2]]
(* 0.000383406 *)

test[.002]["Domain"][[1, 2]]
(* 1. *)

c = 0.0005; d = 0.002; Under = 1; Monitor[
Quiet[While[c >= 10^(-18), While[Under == 1, d = d - c; If[test[d]["Domain"][[1, 2]] < 1,
    Under = 0];]; d = d + c; c = c/10; s = d; Under = 1;];], d]
NumberForm[s, 16]
(* 0.001701281449747991 *)

dl = c; du = d;
Do[dt = (dl + du)/2; If[Quiet@test[dt]["Domain"][[1, 2]] < 1, dl = dt, du = dt], {i, 20}]
NumberForm[du, 16]
(* 0.001701281449747996 *)