2 files changed, 25 insertions(+), 13 deletions(-)

M gnu/system/vm.scm
M guix/build/vm.scm

@@ 196,15 196,17 @@ made available under the /xchg CIFS share."
                      (disk-image-size (* 100 (expt 2 20)))
                      (disk-image-format "qcow2")
                      (file-system-type "ext4")
+                     file-system-label
                      grub-configuration
                      (register-closures? #t)
                      (inputs '())
                      copy-inputs?)
   "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
-'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.  The
-returned image is a full disk image, with a GRUB installation that uses
-GRUB-CONFIGURATION as its configuration file (GRUB-CONFIGURATION must be the
-name of a file in the VM.)
+'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
+Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
+partition.  The returned image is a full disk image, with a GRUB installation
+that uses GRUB-CONFIGURATION as its configuration file (GRUB-CONFIGURATION
+must be the name of a file in the VM.)
 
 INPUTS is a list of inputs (as for packages).  When COPY-INPUTS? is true, copy
 all of INPUTS into the image being built.  When REGISTER-CLOSURES? is true,


@@ 243,7 245,8 @@ the image."
                                   #:copy-closures? #$copy-inputs?
                                   #:register-closures? #$register-closures?
                                   #:disk-image-size #$disk-image-size
-                                  #:file-system-type #$file-system-type)
+                                  #:file-system-type #$file-system-type
+                                  #:file-system-label #$file-system-label)
             (reboot))))
     #:system system
     #:make-disk-image? #t

@@ 158,10 158,16 @@ REFERENCE-GRAPHS, a list of reference-graph files."
 
 (define MS_BIND 4096)                             ; <sys/mounts.h> again!
 
-(define (format-partition partition type)
-  "Create a file system TYPE on PARTITION."
+(define* (format-partition partition type
+                           #:key label)
+  "Create a file system TYPE on PARTITION.  If LABEL is true, use that as the
+volume name."
   (format #t "creating ~a partition...\n" type)
-  (unless (zero? (system* (string-append "mkfs." type) "-F" partition))
+  (unless (zero? (apply system* (string-append "mkfs." type)
+                        "-F" partition
+                        (if label
+                            `("-L" ,label)
+                            '())))
     (error "failed to create partition")))
 
 (define* (initialize-root-partition target-directory


@@ 204,13 210,15 @@ REFERENCE-GRAPHS, a list of reference-graph files."
                                grub.cfg
                                disk-image-size
                                (file-system-type "ext4")
+                               file-system-label
                                (closures '())
                                copy-closures?
                                (register-closures? #t))
-  "Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a
-FILE-SYSTEM-TYPE partition, and with GRUB installed.  If REGISTER-CLOSURES? is
-true, register all of CLOSURES is the partition's store.  If COPY-CLOSURES? is
-true, copy all of CLOSURES to the partition."
+  "Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a FILE-SYSTEM-TYPE
+partition with (optionally) FILE-SYSTEM-LABEL as its volume name, and with
+GRUB installed.  If REGISTER-CLOSURES? is true, register all of CLOSURES is
+the partition's store.  If COPY-CLOSURES? is true, copy all of CLOSURES to the
+partition."
   (define target-directory
     "/fs")
 


@@ 220,7 228,8 @@ true, copy all of CLOSURES to the partition."
   (initialize-partition-table device
                               (- disk-image-size (* 5 (expt 2 20))))
 
-  (format-partition partition file-system-type)
+  (format-partition partition file-system-type
+                    #:label file-system-label)
 
   (display "mounting partition...\n")
   (mkdir target-directory)