cs: fix struct constructor result for object-name

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

@@ -124,6 +124,9 @@
   (test (string->symbol "CP")
 	object-name
 	(eval (read (open-input-string "(let () (define-struct CP (a)) make-CP)"))))
+  (test (string->symbol "mk-CP")
+	object-name
+	(eval (read (open-input-string "(let () (struct CP (a) #:constructor-name mk-CP) mk-CP)"))))
   (test (string->symbol "CP?")
 	object-name
 	(eval (read (open-input-string "(let () (define-struct CP (a)) CP?)"))))

racket/src/cs/convert.rkt

@@ -8,7 +8,8 @@
          "../schemify/schemify.rkt"
          "../schemify/serialize.rkt"
          "../schemify/known.rkt"
-         "../schemify/lift.rkt")
+         "../schemify/lift.rkt"
+         "../schemify/wrap.rkt")
 
 (define skip-export? #f)
 (define for-cify? #f)
@@ -208,6 +209,13 @@
 ;; in general.
 (define (rename-functions e)
   (cond
+    [(wrap? e)
+     (cond
+       [(wrap-property e 'inferred-name)
+        => (lambda (name)
+             `(#%name ,name ,(rename-functions (unwrap e))))]
+       [else
+        (rename-functions (unwrap e))])]
     [(not (pair? e)) e]
     [else
      (define (begin-name e)

racket/src/schemify/struct-convert.rkt

@@ -64,12 +64,25 @@
                                                       ,@(schemify-body schemify knowns (struct-type-info-rest sti))))))
            (define ,make-s ,(let ([ctr `(record-constructor
                                          (make-record-constructor-descriptor ,struct:s #f #f))])
+                              (define ctr-expr
                                 (if (struct-type-info-pure-constructor? sti)
                                     ctr
-                                  `(struct-type-constructor-add-guards ,ctr ,struct:s ',(struct-type-info-name sti)))))
+                                    `(struct-type-constructor-add-guards ,ctr ,struct:s ',(struct-type-info-name sti))))
+                              (define name-expr (struct-type-info-constructor-name-expr sti))
+                              (match name-expr
+                                [`#f
+                                 (wrap-property-set ctr-expr 'inferred-name (struct-type-info-name sti))]
+                                [`',sym
+                                 (if (symbol? sym)
+                                     (wrap-property-set ctr-expr 'inferred-name sym)
+                                     `(procedure-rename ,ctr-expr ,name-expr))]
+                                [`,_
+                                 `(procedure-rename ,ctr-expr ,name-expr)])))
            (define ,raw-s? (record-predicate ,struct:s))
            ,@(if can-impersonate?
-                 `((define ,s? (lambda (v) (if (,raw-s? v) #t ($value (if (impersonator? v) (,raw-s? (impersonator-val v)) #f))))))
+                 `((define ,s? ,(name-procedure
+                                 "" (struct-type-info-name sti) "" '|| "?"
+                                 `(lambda (v) (if (,raw-s? v) #t ($value (if (impersonator? v) (,raw-s? (impersonator-val v)) #f)))))))
                  null)
            ,@(for/list ([acc/mut (in-list acc/muts)]
                         [make-acc/mut (in-list make-acc/muts)])
@@ -81,10 +94,12 @@
                       `(begin
                          ,raw-def
                          (define ,acc/mut
-                           (lambda (s) (if (,raw-s? s)
+                           ,(name-procedure
+                             "" (struct-type-info-name sti) "-" field-name ""
+                             `(lambda (s) (if (,raw-s? s)
                                               (,raw-acc/mut s)
                                               ($value (impersonate-ref ,raw-acc/mut ,struct:s ,pos s
-                                                                    ',(struct-type-info-name sti) ',field-name))))))
+                                                                       ',(struct-type-info-name sti) ',field-name)))))))
                       raw-def)]
                  [`(make-struct-field-mutator ,(? (lambda (v) (wrap-eq? v -set!))) ,pos ',field-name)
                   (define raw-def `(define ,raw-acc/mut (record-mutator ,struct:s ,pos)))
@@ -94,10 +109,12 @@
                       `(begin
                          ,raw-def
                          (define ,acc/mut
-                           (lambda (s v) (if (,raw-s? s)
+                           ,(name-procedure
+                             "set-" (struct-type-info-name sti) "-" field-name "!"
+                             `(lambda (s v) (if (,raw-s? s)
                                                 (,raw-acc/mut s v)
                                                 ($value (impersonate-set! ,raw-acc/mut ,struct:s ,pos ,abs-pos s v
-                                                                       ',(struct-type-info-name sti) ',field-name))))))
+                                                                          ',(struct-type-info-name sti) ',field-name)))))))
                       raw-def)]
                  [`,_ (error "oops")]))
            (define ,(gensym)
@@ -161,3 +178,13 @@
 (define (schemify-body schemify knowns l)
   (for/list ([e (in-list l)])
     (schemify e knowns)))
+
+(define (name-procedure pre st sep fld post proc-expr)
+  (wrap-property-set proc-expr
+                     'inferred-name
+                     (string->symbol
+                      (string-append pre
+                                     (symbol->string st)
+                                     sep
+                                     (symbol->string fld)
+                                     post))))

racket/src/schemify/struct-type-info.rkt

@@ -18,6 +18,7 @@
                                pure-constructor?
                                authentic?
                                prefab-immutables ; #f or immutable expression to be quoted
+                               constructor-name-expr  ; an expression
                                rest)) ; argument expressions after auto-field value
 (define struct-type-info-rest-properties-list-pos 0)
 
@@ -58,6 +59,8 @@
                         (for/or ([prop (in-list props)])
                           (eq? (unwrap prop) name))]
                        [`,_ #f])))
+              (define constructor-name-expr (and ((length rest) . > . 5)
+                                                 (list-ref rest 5)))
               (and prefab-imms
                    (struct-type-info name
                                      parent
@@ -75,6 +78,7 @@
                                      (if (eq? prefab-imms 'non-prefab)
                                          #f
                                          prefab-imms)
+                                     constructor-name-expr
                                      rest)))))]
     [`(let-values () ,body)
      (make-struct-type-info body prim-knowns knowns imports mutated)]

racket/src/schemify/wrap.rkt

@@ -84,7 +84,10 @@
        (correlated-property a key)))
 
 (define (wrap-property-set a key val)
-  (correlated-property a key val))
+  (let ([a (if (correlated? a)
+               a
+               (datum->correlated #f a #f #f))])
+    (correlated-property a key val)))
 
 (define (wrap-source a)
   (cond