Make prop:rename-transformer accept a procedure

Allows the choice of target identifier to be delayed
until expansion time, rather than fixed at the point of
the transformer definition.

pkgs/racket-doc/scribblings/reference/stx-trans.scrbl

@@ -181,8 +181,9 @@ A @tech{structure type property} to identify structure types that act
 as @tech{rename transformers} like the ones created by
 @racket[make-rename-transformer].
 
-The property value must be an exact integer or an identifier
-@tech{syntax object}. In the former case, the integer designates a
+The property value must be an exact integer, an identifier
+@tech{syntax object}, or a procedure that takes one argument.
+In the former case, the integer designates a
 field within the structure that should contain an identifier; the
 integer must be between @racket[0] (inclusive) and the number of
 non-automatic fields in the structure type (exclusive, not counting
@@ -194,7 +195,35 @@ target for renaming, just like the first argument to
 @racket[make-rename-transformer]. If the property value is an integer,
 the target identifier is extracted from the structure instance; if the
 field value is not an identifier, then an identifier @racketidfont{?}
-with an empty context is used, instead.}
+with an empty context is used, instead.
+
+If the property value is a procedure that takes one argument, then the procedure
+is called to obtain the identifier that the rename transformer will use
+as a target identifier. If the procedure returns any value that is not
+an identifier, the @racket[exn:fail:contract] exception is raised.
+
+@examples[#:eval stx-eval #:escape UNSYNTAX
+  (code:comment "Example of a procedure argument for prop:rename-transformer")
+  (define-syntax slv-1 'first-transformer-binding)
+  (define-syntax slv-2 'second-transformer-binding)
+  (begin-for-syntax
+    (struct slv-cooperator (redirect-to-first?)
+      #:property prop:rename-transformer
+      (λ (inst)
+        (if (slv-cooperator-redirect-to-first? inst)
+            #'slv-1
+            #'slv-2))))
+  (define-syntax (slv-lookup stx)
+    (syntax-case stx ()
+      [(_ id)
+       #`(quote #,(syntax-local-value #'id))]))
+  (define-syntax slv-inst-1 (slv-cooperator #t))
+  (define-syntax slv-inst-2 (slv-cooperator #f))
+  (slv-lookup slv-inst-1)
+  (slv-lookup slv-inst-2)
+]
+
+@history[#:changed "6.3" "the property now accepts a procedure of one argument."]}
 
 
 @defproc[(local-expand [stx any/c]

pkgs/racket-test-core/tests/racket/stx.rktl

@@ -2105,6 +2105,88 @@
   (check stx #f)
   (check #f a-stx))
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Test prop:rename-transformer with procedure content
+
+(begin-for-syntax
+  (struct slv-struct-1 (id)
+    #:property prop:rename-transformer
+    (λ (o) (slv-struct-1-id o)))
+
+  (struct slv-struct-2 (t1? t1 t2)
+    #:property prop:rename-transformer
+    (λ (o)
+      (if (slv-struct-2-t1? o)
+          (slv-struct-2-t1 o)
+          (slv-struct-2-t2 o))))
+
+  (struct slv-struct-bad ()
+    #:property prop:rename-transformer
+    (λ (o) 'not-an-identifier)))
+
+(let ()
+  (define-syntax target-1 't1)
+  (define-syntax target-2 't2)
+
+  (define-syntax (m stx)
+    (syntax-case stx ()
+      [(_ id)
+       #`(quote #,(syntax-local-value #'id) )]))
+
+  (define-syntax (m2 stx)
+    (syntax-case stx ()
+      [(_ id)
+       (let-values ([(x y) (syntax-local-value/immediate #'id)])
+         #`(list (quote #,(if (rename-transformer? x) 'rename-transformer x))
+                 (quote #,(and y (syntax-e y)))))]))
+
+  (define-syntax s1 (slv-struct-1 #'target-1))
+  (define-syntax s2 (slv-struct-1 #'target-2))
+  (define-syntax s3 (make-rename-transformer #'target-2))
+  (define-syntax s4 (slv-struct-1 #'s3))
+  (define-syntax s5 (slv-struct-2 #t #'target-1 #'target-2))
+  (define-syntax s6 (slv-struct-2 #f #'target-1 #'target-2))
+  (define-syntax s7 (slv-struct-2 #t #'s3 #'target-2))
+  (define-syntax s8 (slv-struct-2 #f #'s3 #'target-2))
+  (define-syntax s9 (make-rename-transformer #'s8))
+
+  (test 't1 values (m s1))
+  (test '(rename-transformer target-1) values (m2 s1))
+  (test 't2 values (m s2))
+  (test '(rename-transformer target-2) values (m2 s2))
+  (test 't2 values (m s4))
+  (test '(rename-transformer s3) values (m2 s4))
+  (test 't1 values (m s5))
+  (test '(rename-transformer target-1) values (m2 s5))
+  (test 't2 values (m s6))
+  (test '(rename-transformer target-2) values (m2 s6))
+  (test 't2 values (m s7))
+  (test '(rename-transformer s3) values (m2 s7))
+  (test 't2 values (m s8))
+  (test '(rename-transformer target-2) values (m2 s8))
+  (test 't2 values (m s9))
+  (test '(rename-transformer s8) values (m2 s9))
+
+  (define target-3 't3)
+  (define target-4 't4)
+  (define-syntax r1 (slv-struct-1 #'target-3))
+  (define-syntax r2 (slv-struct-1 #'target-4))
+  (define-syntax r3 (slv-struct-2 #t #'target-3 #'target-4))
+  (define-syntax r4 (slv-struct-2 #f #'target-3 #'target-4))
+  (test 't3 values r1)
+  (test 't4 values r2)
+  (test 't3 values r3)
+  (test 't4 values r4)
+
+  (err/rt-test
+   (let ()
+     (struct foo () #:property prop:rename-transformer (λ (x y) 3))
+     (void))
+   exn:fail:contract?)
+  (err/rt-test
+   (eval #'(let () (define-syntax s-bad (slv-struct-bad)) (m s-bad)))
+   exn:fail:contract?))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (report-errs)

racket/src/racket/src/struct.c

@@ -1882,14 +1882,30 @@ int scheme_is_binding_rename_transformer(Scheme_Object *o)
 
 static int is_stx_id(Scheme_Object *o) { return (SCHEME_STXP(o) && SCHEME_SYMBOLP(SCHEME_STX_VAL(o))); }
 
+static int is_stx_id_or_proc_1(Scheme_Object *o) { return (is_stx_id(o) || is_proc_1(o)); }
+
 Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o)
 {
+  Scheme_Object *a[1];
+
   if (SAME_TYPE(SCHEME_TYPE(o), scheme_id_macro_type))
     return SCHEME_PTR1_VAL(o);
   if (SCHEME_CHAPERONE_STRUCTP(o)) {
     Scheme_Object *v;
     v = scheme_struct_type_property_ref(rename_transformer_property, o);
-    if (SCHEME_INTP(v)) {
+    if (SCHEME_PROCP(v)) {
+      a[0] = o;
+      /* apply a continuation barrier here to prevent a capture in
+       * the property access */
+      v = scheme_apply(v, 1, a);
+      if (!is_stx_id(v)) {
+        scheme_contract_error("prop:rename-transformer",
+                              "contract violation for given value",
+                              "expected", 0, "identifier?",
+                              "given", 1, v,
+                              NULL);
+      }
+    } else if (SCHEME_INTP(v)) {
       v = scheme_struct_ref(o, SCHEME_INT_VAL(v));
       if (!is_stx_id(v)) {
         v = scheme_datum_to_syntax(scheme_intern_symbol("?"), scheme_false, scheme_false, 0, 0);
@@ -1903,8 +1919,8 @@ Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o)
 static Scheme_Object *check_rename_transformer_property_value_ok(int argc, Scheme_Object *argv[])
 {
   return check_indirect_property_value_ok("guard-for-prop:rename-transformer", 
-                                          is_stx_id, 0,
-                                          "(or/c exact-nonnegative-integer? identifier?)",
+                                          is_stx_id_or_proc_1, 0,
+                                          "(or/c exact-nonnegative-integer? identifier? (-> any/c identifier?))",
                                           argc, argv);
 }