diff --git a/Changes b/Changes
index 46f8ac243ade..e1d32baf090d 100644
--- a/Changes
+++ b/Changes
@@ -8,6 +8,11 @@ Working version
 - GPR#2229: Env: remove prefix_idents cache
   (Thomas Refis, review by Frédéric Bour and Gabriel Scherer)
 
+### Runtime system:
+
+- GPR#1725: Deprecate Obj.set_tag
+  (Stephen Dolan, review by Gabriel Scherer and Damien Doligez)
+
 OCaml 4.08.0
 ------------
 
diff --git a/boot/ocamlc b/boot/ocamlc
index 3413cb02e754..456699a785d3 100755
Binary files a/boot/ocamlc and b/boot/ocamlc differ
diff --git a/boot/ocamllex b/boot/ocamllex
index 5e8e1ab77413..d6501ed4b284 100755
Binary files a/boot/ocamllex and b/boot/ocamllex differ
diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml
index 8011953fb8ba..419b70464ea0 100644
--- a/bytecomp/simplif.ml
+++ b/bytecomp/simplif.ml
@@ -235,6 +235,18 @@ let simplify_exits lam =
                                      ap_args=[x];
                                      ap_inlined=Default_inline;
                                      ap_specialised=Default_specialise}
+        (* Simplify %identity *)
+      | Pidentity, [e] -> e
+
+        (* Simplify Obj.with_tag *)
+      | Pccall { Primitive.prim_name = "caml_obj_with_tag"; _ },
+        [Lconst (Const_base (Const_int tag));
+         Lprim (Pmakeblock (_, mut, shape), fields, loc)] ->
+         Lprim (Pmakeblock(tag, mut, shape), fields, loc)
+      | Pccall { Primitive.prim_name = "caml_obj_with_tag"; _ },
+        [Lconst (Const_base (Const_int tag));
+         Lconst (Const_block (_, fields))] ->
+         Lconst (Const_block (tag, fields))
 
       | _ -> Lprim(p, ll, loc)
      end
diff --git a/runtime/obj.c b/runtime/obj.c
index 4567b8aefca3..4c35535f36b7 100644
--- a/runtime/obj.c
+++ b/runtime/obj.c
@@ -72,6 +72,13 @@ CAMLprim value caml_obj_set_tag (value arg, value new_tag)
   return Val_unit;
 }
 
+CAMLprim value caml_obj_make_forward (value blk, value fwd)
+{
+  caml_modify(&Field(blk, 0), fwd);
+  Tag_val (blk) = Forward_tag;
+  return Val_unit;
+}
+
 /* [size] is a value encoding a number of blocks */
 CAMLprim value caml_obj_block(value tag, value size)
 {
@@ -90,16 +97,16 @@ CAMLprim value caml_obj_block(value tag, value size)
 }
 
 /* Spacetime profiling assumes that this function is only called from OCaml. */
-CAMLprim value caml_obj_dup(value arg)
+CAMLprim value caml_obj_with_tag(value new_tag_v, value arg)
 {
-  CAMLparam1 (arg);
+  CAMLparam2 (new_tag_v, arg);
   CAMLlocal1 (res);
   mlsize_t sz, i;
   tag_t tg;
 
   sz = Wosize_val(arg);
-  if (sz == 0) CAMLreturn (arg);
-  tg = Tag_val(arg);
+  tg = (tag_t)Long_val(new_tag_v);
+  if (sz == 0) CAMLreturn (Atom(tg));
   if (tg >= No_scan_tag) {
     res = caml_alloc(sz, tg);
     memcpy(Bp_val(res), Bp_val(arg), sz * sizeof(value));
@@ -115,6 +122,12 @@ CAMLprim value caml_obj_dup(value arg)
   CAMLreturn (res);
 }
 
+/* Spacetime profiling assumes that this function is only called from OCaml. */
+CAMLprim value caml_obj_dup(value arg)
+{
+  return caml_obj_with_tag(Val_long(Tag_val(arg)), arg);
+}
+
 /* Shorten the given block to the given size and return void.
    Raise Invalid_argument if the given size is less than or equal
    to 0 or greater than the current size.
diff --git a/stdlib/camlinternalLazy.ml b/stdlib/camlinternalLazy.ml
index bc727b73d768..8226ffda2e34 100644
--- a/stdlib/camlinternalLazy.ml
+++ b/stdlib/camlinternalLazy.ml
@@ -21,15 +21,15 @@ exception Undefined
 
 let raise_undefined = Obj.repr (fun () -> raise Undefined)
 
+external make_forward : Obj.t -> Obj.t -> unit = "caml_obj_make_forward"
+
 (* Assume [blk] is a block with tag lazy *)
 let force_lazy_block (blk : 'arg lazy_t) =
   let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in
   Obj.set_field (Obj.repr blk) 0 raise_undefined;
   try
     let result = closure () in
-    (* do set_field BEFORE set_tag *)
-    Obj.set_field (Obj.repr blk) 0 (Obj.repr result);
-    Obj.set_tag (Obj.repr blk) Obj.forward_tag;
+    make_forward (Obj.repr blk) (Obj.repr result);
     result
   with e ->
     Obj.set_field (Obj.repr blk) 0 (Obj.repr (fun () -> raise e));
@@ -41,9 +41,7 @@ let force_val_lazy_block (blk : 'arg lazy_t) =
   let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in
   Obj.set_field (Obj.repr blk) 0 raise_undefined;
   let result = closure () in
-  (* do set_field BEFORE set_tag *)
-  Obj.set_field (Obj.repr blk) 0 (Obj.repr result);
-  Obj.set_tag (Obj.repr blk) (Obj.forward_tag);
+  make_forward (Obj.repr blk) (Obj.repr result);
   result
 
 
diff --git a/stdlib/camlinternalMod.ml b/stdlib/camlinternalMod.ml
index 5ccf92893b2d..7c4b78ee37d8 100644
--- a/stdlib/camlinternalMod.ml
+++ b/stdlib/camlinternalMod.ml
@@ -13,6 +13,8 @@
 (*                                                                        *)
 (**************************************************************************)
 
+external make_forward : Obj.t -> Obj.t -> unit = "caml_obj_make_forward"
+
 type shape =
   | Function
   | Lazy
@@ -56,12 +58,10 @@ let rec update_mod shape o n =
       if Obj.tag n = Obj.lazy_tag then
         Obj.set_field o 0 (Obj.field n 0)
       else if Obj.tag n = Obj.forward_tag then begin (* PR#4316 *)
-        Obj.set_tag o Obj.forward_tag;
-        Obj.set_field o 0 (Obj.field n 0)
+        make_forward o (Obj.field n 0)
       end else begin
         (* forwarding pointer was shortcut by GC *)
-        Obj.set_tag o Obj.forward_tag;
-        Obj.set_field o 0 n
+        make_forward o n
       end
   | Class ->
       assert (Obj.tag n = 0 && Obj.size n = 4);
diff --git a/stdlib/obj.ml b/stdlib/obj.ml
index b2269a95c2ff..32049d72b3af 100644
--- a/stdlib/obj.ml
+++ b/stdlib/obj.ml
@@ -38,6 +38,7 @@ external new_block : int -> int -> t = "caml_obj_block"
 external dup : t -> t = "caml_obj_dup"
 external truncate : t -> int -> unit = "caml_obj_truncate"
 external add_offset : t -> Int32.t -> t = "caml_obj_add_offset"
+external with_tag : int -> t -> t = "caml_obj_with_tag"
 
 let marshal (obj : t) =
   Marshal.to_bytes obj []
diff --git a/stdlib/obj.mli b/stdlib/obj.mli
index bac04d569bce..62f208e6ff1f 100644
--- a/stdlib/obj.mli
+++ b/stdlib/obj.mli
@@ -55,6 +55,7 @@ external field : t -> int -> t = "%obj_field"
 *)
 external set_field : t -> int -> t -> unit = "%obj_set_field"
 external set_tag : t -> int -> unit = "caml_obj_set_tag"
+  [@@ocaml.deprecated "Use with_tag instead."]
 
 val [@inline always] double_field : t -> int -> float  (* @since 3.11.2 *)
 val [@inline always] set_double_field : t -> int -> float -> unit
@@ -64,6 +65,8 @@ external dup : t -> t = "caml_obj_dup"
 external truncate : t -> int -> unit = "caml_obj_truncate"
 external add_offset : t -> Int32.t -> t = "caml_obj_add_offset"
          (* @since 3.12.0 *)
+external with_tag : int -> t -> t = "caml_obj_with_tag"
+  (* @since 4.09.0 *)
 
 val first_non_constant_constructor_tag : int
 val last_non_constant_constructor_tag : int
diff --git a/testsuite/tests/backtrace/backtrace2.byte.reference b/testsuite/tests/backtrace/backtrace2.byte.reference
index 36465dc0f530..296d4328a6ab 100644
--- a/testsuite/tests/backtrace/backtrace2.byte.reference
+++ b/testsuite/tests/backtrace/backtrace2.byte.reference
@@ -46,13 +46,13 @@ Called from file "backtrace2.ml", line 52, characters 43-52
 Called from file "backtrace2.ml", line 52, characters 43-52
 Called from file "backtrace2.ml", line 52, characters 43-52
 Called from file "backtrace2.ml", line 52, characters 43-52
-Called from file "camlinternalLazy.ml", line 29, characters 17-27
+Called from file "camlinternalLazy.ml", line 31, characters 17-27
 Re-raised at file "camlinternalLazy.ml", line 36, characters 10-11
 Called from file "backtrace2.ml", line 67, characters 11-23
 Uncaught exception Not_found
 Raised at file "hashtbl.ml", line 194, characters 19-28
 Called from file "backtrace2.ml", line 55, characters 8-41
 Re-raised at file "camlinternalLazy.ml", line 35, characters 62-63
-Called from file "camlinternalLazy.ml", line 29, characters 17-27
+Called from file "camlinternalLazy.ml", line 31, characters 17-27
 Re-raised at file "camlinternalLazy.ml", line 36, characters 10-11
 Called from file "backtrace2.ml", line 67, characters 11-23
diff --git a/testsuite/tests/backtrace/backtrace2.opt.reference b/testsuite/tests/backtrace/backtrace2.opt.reference
index c0b9816b7dbb..2c246e2db2c4 100644
--- a/testsuite/tests/backtrace/backtrace2.opt.reference
+++ b/testsuite/tests/backtrace/backtrace2.opt.reference
@@ -46,13 +46,13 @@ Called from file "backtrace2.ml", line 52, characters 43-52
 Called from file "backtrace2.ml", line 52, characters 43-52
 Called from file "backtrace2.ml", line 52, characters 43-52
 Called from file "backtrace2.ml", line 52, characters 43-52
-Called from file "camlinternalLazy.ml", line 29, characters 17-27
+Called from file "camlinternalLazy.ml", line 31, characters 17-27
 Re-raised at file "camlinternalLazy.ml", line 36, characters 4-11
 Called from file "backtrace2.ml", line 67, characters 11-23
 Uncaught exception Not_found
 Raised at file "hashtbl.ml", line 194, characters 13-28
 Called from file "backtrace2.ml", line 55, characters 8-41
 Re-raised at file "camlinternalLazy.ml", line 35, characters 56-63
-Called from file "camlinternalLazy.ml", line 29, characters 17-27
+Called from file "camlinternalLazy.ml", line 31, characters 17-27
 Re-raised at file "camlinternalLazy.ml", line 36, characters 4-11
 Called from file "backtrace2.ml", line 67, characters 11-23
diff --git a/testsuite/tests/lib-obj/ocamltests b/testsuite/tests/lib-obj/ocamltests
index 55f0b5b30992..bdddfe9e7fef 100644
--- a/testsuite/tests/lib-obj/ocamltests
+++ b/testsuite/tests/lib-obj/ocamltests
@@ -1 +1,2 @@
 reachable_words.ml
+with_tag.ml
diff --git a/testsuite/tests/lib-obj/with_tag.ml b/testsuite/tests/lib-obj/with_tag.ml
new file mode 100644
index 000000000000..a4b69ea1d437
--- /dev/null
+++ b/testsuite/tests/lib-obj/with_tag.ml
@@ -0,0 +1,31 @@
+(* TEST
+*)
+
+type t =
+| A of string * float
+| B of string * float
+
+let () =
+  assert (Obj.dup (Obj.repr (A ("hello", 10.))) = Obj.repr (A ("hello", 10.)));
+  assert (Obj.with_tag 1 (Obj.repr (A ("hello", 10.))) = Obj.repr (B ("hello", 10.)))
+
+let () =
+  assert (Obj.tag (Obj.with_tag 42 (Obj.repr [| |])) = 42)
+
+(* check optimisations *)
+let raw_allocs f =
+  let before = Gc.minor_words () in
+  f ();
+  let after = Gc.minor_words () in
+  int_of_float (after -. before)
+
+let allocs =
+  let overhead = raw_allocs (fun () -> ()) in
+  fun f -> raw_allocs f - overhead
+
+let () =
+  assert (allocs (fun () -> Obj.with_tag 1 (Obj.repr (A ("hello", 10.)))) = 0);
+  assert (allocs (fun () -> Obj.with_tag 1 (Obj.repr (ref 10))) = 2)
+
+let () =
+  print_endline "ok"
diff --git a/testsuite/tests/lib-obj/with_tag.reference b/testsuite/tests/lib-obj/with_tag.reference
new file mode 100644
index 000000000000..9766475a4185
--- /dev/null
+++ b/testsuite/tests/lib-obj/with_tag.reference
@@ -0,0 +1 @@
+ok