Enforce that flat contracts return the original value.

Also fix up tail call contract handling, which was affected by this change.

collects/racket/contract/private/arrow.rkt

@@ -1457,7 +1457,7 @@ v4 todo:
             (λ (first-mark)
               (if (and first-mark
                        (= (length first-mark) count)
-                       (andmap eq? fs first-mark))
+                       (andmap procedure-closure-contents-eq? fs first-mark))
                   (thunk)
                   (let-values ([(x ...) (with-continuation-mark multiple-contract-key fs
                                           (thunk))])
@@ -1477,7 +1477,7 @@ v4 todo:
   (call-with-immediate-continuation-mark
    single-contract-key
    (λ (first-mark)  ;; note this is #f if there is no mark (so if #f can be a contract, something must change)
-     (if (eq? first-mark ctc)
+     (if (and first-mark (procedure-closure-contents-eq? first-mark ctc))
          (thnk)
          (ctc
           (with-continuation-mark single-contract-key ctc

collects/racket/contract/private/prop.rkt

@@ -108,7 +108,7 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define ((build-property mk default-name)
+(define ((build-property mk default-name projection-wrapper)
          #:name [get-name #f]
          #:first-order [get-first-order #f]
          #:projection [get-projection #f]
@@ -117,19 +117,31 @@
 
   (let* ([get-name (or get-name (lambda (c) default-name))]
          [get-first-order (or get-first-order get-any?)]
-         [get-projection (or get-projection
+         [get-projection
-                             (get-first-order-projection
+          (cond
-                              get-name get-first-order))]
+            [get-projection (projection-wrapper get-projection)]
+            [else (get-first-order-projection
+                   get-name get-first-order)])]
          [stronger (or stronger weakest)])
 
     (mk get-name get-first-order get-projection stronger generator)))
 
 (define build-contract-property
-  (build-property make-contract-property 'anonymous-contract))
+  (build-property make-contract-property 'anonymous-contract values))
+
+;; Here we'll force the projection to always return the original value,
+;; instead of assuming that the provided projection does so appropriately.
+(define (flat-projection-wrapper f)
+  (λ (c)
+    (let ([proj (f c)])
+      (λ (b)
+        (let ([p (proj b)])
+          (λ (v) (p v) v))))))
 
 (define build-flat-contract-property
   (build-property (compose make-flat-contract-property make-contract-property)
-                  'anonymous-flat-contract))
+                  'anonymous-flat-contract
+                  flat-projection-wrapper))
 
 (define (get-any? c) any?)
 (define (any? x) #t)
@@ -153,23 +165,22 @@
 (define-struct make-contract [ name first-order projection stronger ]
   #:omit-define-syntaxes
   #:property prop:contract
-  (make-contract-property
+  (build-contract-property
-   (lambda (c) (make-contract-name c))
+   #:name (lambda (c) (make-contract-name c))
-   (lambda (c) (make-contract-first-order c))
+   #:first-order (lambda (c) (make-contract-first-order c))
-   (lambda (c) (make-contract-projection c))
+   #:projection (lambda (c) (make-contract-projection c))
-   (lambda (a b) ((make-contract-stronger a) a b))
+   #:stronger (lambda (a b) ((make-contract-stronger a) a b))
-   #f))
+   #:generator #f))
 
 (define-struct make-flat-contract [ name first-order projection stronger ]
   #:omit-define-syntaxes
   #:property prop:flat-contract
-  (make-flat-contract-property
+  (build-flat-contract-property
-   (make-contract-property
+   #:name (lambda (c) (make-flat-contract-name c))
-    (lambda (c) (make-flat-contract-name c))
+   #:first-order (lambda (c) (make-flat-contract-first-order c))
-    (lambda (c) (make-flat-contract-first-order c))
+   #:projection (lambda (c) (make-flat-contract-projection c))
-    (lambda (c) (make-flat-contract-projection c))
+   #:stronger (lambda (a b) ((make-flat-contract-stronger a) a b))
-    (lambda (a b) ((make-flat-contract-stronger a) a b))
+   #:generator #f))
-    #f)))
 
 (define ((build-contract mk default-name)
          #:name [name #f]

collects/tests/racket/contract-test.rktl

@@ -3670,6 +3670,71 @@
    'make-contract-4
    '((contract proj:add1->sub1 sqrt 'pos 'neg) 'dummy))
   
+  (ctest #t contract? proj:add1->sub1)
+  (ctest #f flat-contract? proj:add1->sub1)
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;;  make-flat-contract
+  ;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  
+  (contract-eval
+   '(define proj:prime/c
+      (let ([prime? (λ (n)
+                      (for/and ([m (in-range 2 (add1 (floor (sqrt n))))])
+                        (not (= (remainder n m) 0))))])
+        (make-flat-contract
+         #:name 'prime/c
+         #:first-order prime?))))
+  
+  (test/spec-passed/result
+   'make-flat-contract-1
+   '(contract proj:prime/c 2 'pos 'neg)
+   2)
+  
+  (test/pos-blame
+   'make-flat-contract-2
+   '(contract proj:prime/c 4 'pos 'neg))
+
+  (ctest #t contract? proj:prime/c)
+  (ctest #t flat-contract? proj:prime/c)
+  
+  ;; Check to make sure that flat contracts always return the original value,
+  ;; even if the projection is written badly.
+  (contract-eval
+   '(define proj:prime-list/c
+      (let ([prime? (λ (n)
+                      (for/and ([m (in-range 2 (add1 (floor (sqrt n))))])
+                        (not (= (remainder n m) 0))))])
+        (make-flat-contract
+         #:name 'prime-list/c
+         #:first-order (λ (v) (and (list? v) (andmap prime? v)))
+         #:projection (λ (b)
+                        (λ (v)
+                          (unless (and (list? v) (andmap prime? v))
+                            (raise-blame-error b v "expected prime list, got ~v" v))
+                          (map values v)))))))
+  
+  (test/spec-passed/result
+   'make-flat-contract-bad-1
+   '(contract proj:prime-list/c (list 2 3 5 7) 'pos 'neg)
+   (list 2 3 5 7))
+  
+  (test/pos-blame
+   'make-flat-contract-bad-2
+   '(contract proj:prime-list/c (list 2 3 4 5) 'pos 'neg))
+  
+  (test/spec-passed/result
+   'make-flat-contract-bad-3
+   '(let ([l (list 2 3 5 7)])
+      (eq? l (contract proj:prime-list/c l 'pos 'neg)))
+   #t)
+
+  (ctest #t contract? proj:prime-list/c)
+  (ctest #t flat-contract? proj:prime-list/c)
+  
+  
 ;                                                                                           
 ;                                                                                           
 ;                                                                                           
@@ -9539,7 +9604,10 @@ so that propagation occurs.
              (f 3))
            (c)))
   
-  (ctest 2
+  ;; Robby had this as 2, but now we only end up checking it once, which
+  ;; looks right to me.  Not sure whether "2" was _wanted_, or if it just
+  ;; happened to be what it returned when run.
+  (ctest 1
          'case->-regular
          (let ([c (counter)])
            (letrec ([f