cs: fix procedure-extract-target for applicable struct result

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

@@ -472,6 +472,28 @@
 (err/rt-test (procedure-reduce-keyword-arity void 1 null '(#:b #:a))
              (lambda (exn) (regexp-match #rx"position: 4th" (exn-message exn))))
 
+
+;; ----------------------------------------
+;; Check `procedure-extract-target`
+
+(let ()
+  (struct p (v)
+    #:property prop:procedure 0)
+
+  (define (f x [y 0]) x)
+
+  (define pf (p f))
+  (define ppf (p pf))
+
+  (test #t eq? f (procedure-extract-target pf))
+  (test #t eq? pf (procedure-extract-target ppf))
+
+  (define r (procedure-reduce-arity f 1))
+  (test #t not (procedure-extract-target r))
+
+  (define rpf (procedure-reduce-arity pf 1))
+  (test #t not (procedure-extract-target rpf)))
+
 ;; ----------------------------------------
 ;; Check mutation of direct-called keyword procedure
 

racket/src/cs/rumble/procedure.ss

@@ -257,15 +257,21 @@
 (define/who (procedure-extract-target f)
   (cond
    [(record? f)
-    (let* ([rtd (record-rtd f)]
-           [v (struct-property-ref prop:procedure rtd #f)])
-      (cond
-       [(fixnum? v)
-        (let ([v (unsafe-struct-ref f v)])
-          (and (#%procedure? v) v))]
-       [else
-        (check who procedure? f)
-        #f]))]
+    (cond
+     [(or (reduced-arity-procedure? f)
+          (named-procedure? f)
+          (method-procedure? f))
+      #f]
+     [else
+      (let* ([rtd (record-rtd f)]
+             [v (struct-property-ref prop:procedure rtd #f)])
+        (cond
+         [(fixnum? v)
+          (let ([v (unsafe-struct-ref f v)])
+            (and (procedure? v) v))]
+         [else
+          (check who procedure? f)
+          #f]))])]
    [else
     (check who procedure? f)
     #f]))