Adjusts the contract system so that it preserves the names of functions.

closes PR 11220

Altho, this does not fix the case where a function is being passed thru
another contracted function. Eg, when you give the identity function
this contract: (-> (-> integer? integer?) (-> integer? integer?))
if you pass some function with a name in there, it won't come
back with a name anymore (indeed, it won't even have the name
anymore in the body of the function).

For that, the fix would have to be put into each of the function
contract combinators.

collects/racket/contract/private/arrow.rkt

@@ -39,7 +39,7 @@ v4 todo:
          procedure-accepts-and-more?
          check-procedure
          check-procedure/more
-         make-contracted-function)
+         (struct-out contracted-function))
 
 (define-syntax-parameter making-a-method #f)
 (define-for-syntax (make-this-parameters id)

collects/racket/contract/private/base.rkt

@@ -18,7 +18,8 @@ improve method arity mismatch contract violation error messages?
          unstable/srcloc
          unstable/location
          "guts.rkt"
-         "blame.rkt")
+         "blame.rkt"
+         "arrow.rkt")
 
 (define-syntax-parameter current-contract-region
   (λ (stx) #'(quote-module-path)))
@@ -40,9 +41,27 @@ improve method arity mismatch contract violation error messages?
 (define (apply-contract c v pos neg name loc usr)
   (let ([c (coerce-contract 'contract c)])
     (check-source-location! 'contract loc)
-    (((contract-projection c)
+    (let ([new-val
-      (make-blame loc name (contract-name c) pos neg usr #t))
+           (((contract-projection c)
-     v)))
+             (make-blame loc name (contract-name c) pos neg usr #t))
+            v)])
+      (if (and name 
+               (not (parameter? new-val))  ;; when PR 11221 is fixed, remove this line
+               (procedure? new-val)
+               (not (eq? name (object-name new-val))))
+          (cond
+            [(contracted-function? new-val)
+             ;; when PR11222 is fixed, change these things:
+             ;;   - eliminate this cond case
+             ;;   - remove the require of arrow.rkt above
+             ;;   - change (struct-out contracted-function) 
+             ;;     in arrow.rkt to make-contracted-function
+             (make-contracted-function 
+              (procedure-rename (contracted-function-proc new-val) name)
+              (contracted-function-ctc new-val))]
+            [else
+             (procedure-rename new-val name)])
+          new-val))))
 
 (define-syntax (recursive-contract stx)
   (syntax-case stx ()

collects/tests/racket/contract-test.rktl

@@ -9066,11 +9066,11 @@ so that propagation occurs.
 ;                                                                                                               
 
   (contract-eval 
-   '(module contract-test-suite-inferred-name1 scheme/base
+   '(module contract-test-suite-inferred-name1 racket/base
-      (require scheme/contract)
+      (require racket/contract)
       (define contract-inferred-name-test-contract (-> integer? any))
-      (define (contract-inferred-name-test x) #t)
+      (define (contract-inferred-name-test1 x) #t)
-      (provide/contract (contract-inferred-name-test contract-inferred-name-test-contract))
+      (provide/contract (contract-inferred-name-test1 contract-inferred-name-test-contract))
       
       (define (contract-inferred-name-test2 x) x)
       (provide/contract (contract-inferred-name-test2 (-> number? number?)))
@@ -9086,10 +9086,9 @@ so that propagation occurs.
 
       (define (contract-inferred-name-test5) 7)
       (provide/contract (contract-inferred-name-test5 (->i () () any)))
-
       ))
   (contract-eval '(require 'contract-test-suite-inferred-name1))
-  ;; (eval '(test 'contract-inferred-name-test object-name contract-inferred-name-test)) ;; this one can't be made to pass, sadly.
+  (test 'contract-inferred-name-test1 object-name (contract-eval 'contract-inferred-name-test1))
   (test 'contract-inferred-name-test2 object-name (contract-eval 'contract-inferred-name-test2))
   (test 'contract-inferred-name-test2b object-name (contract-eval 'contract-inferred-name-test2b))
   (test 'contract-inferred-name-test3 object-name (contract-eval 'contract-inferred-name-test3))
@@ -9097,7 +9096,6 @@ so that propagation occurs.
   (test 'contract-inferred-name-test5 object-name (contract-eval 'contract-inferred-name-test5))
   
 
-
 ;                                                                                                                  
 ;                                                                                                                  
 ;